home *** CD-ROM | disk | FTP | other *** search
/ Enter 2004 January / enter-2004-01.iso / files / maxima-5.9.0.exe / {app} / share / maxima / 5.9.0 / src / numerical / slatec / zacai.lisp < prev    next >
Encoding:
Text File  |  2003-02-09  |  4.6 KB  |  121 lines
  1. ;;; Compiled by f2cl version 2.0 beta 2002-05-06
  2. ;;; 
  3. ;;; Options: ((:prune-labels nil) (:auto-save t) (:relaxed-array-decls t)
  4. ;;;           (:coerce-assigns :as-needed) (:array-type ':simple-array)
  5. ;;;           (:array-slicing nil) (:declare-common nil)
  6. ;;;           (:float-format double-float))
  7.  
  8. (in-package "SLATEC")
  9.  
  10.  
  11. (let ((pi_ 3.141592653589793))
  12.   (declare (type double-float pi_))
  13.   (defun zacai (zr zi fnu kode mr n yr yi nz rl tol elim alim)
  14.     (declare (type (simple-array double-float (*)) yr yi)
  15.              (type f2cl-lib:integer4 kode mr n nz)
  16.              (type double-float zr zi fnu rl tol elim alim))
  17.     (prog ((cyr (make-array 2 :element-type 'double-float))
  18.            (cyi (make-array 2 :element-type 'double-float)) (inu 0) (iuf 0)
  19.            (nn 0) (nw 0) (arg 0.0) (ascle 0.0) (az 0.0) (csgnr 0.0) (csgni 0.0)
  20.            (cspnr 0.0) (cspni 0.0) (c1r 0.0) (c1i 0.0) (c2r 0.0) (c2i 0.0)
  21.            (dfnu 0.0) (fmr 0.0) (sgn 0.0) (yy 0.0) (znr 0.0) (zni 0.0))
  22.       (declare (type (simple-array double-float (2)) cyi cyr)
  23.                (type double-float zni znr yy sgn fmr dfnu c2i c2r c1i c1r cspni
  24.                 cspnr csgni csgnr az ascle arg)
  25.                (type f2cl-lib:integer4 nw nn iuf inu))
  26.       (setf nz 0)
  27.       (setf znr (- zr))
  28.       (setf zni (- zi))
  29.       (setf az (zabs zr zi))
  30.       (setf nn n)
  31.       (setf dfnu (+ fnu (f2cl-lib:int-sub n 1)))
  32.       (if (<= az 2.0) (go label10))
  33.       (if (> (* az az 0.25) (+ dfnu 1.0)) (go label20))
  34.      label10
  35.       (multiple-value-bind
  36.           (var-0 var-1 var-2 var-3 var-4 var-5 var-6 var-7 var-8 var-9 var-10)
  37.           (zseri znr zni fnu kode nn yr yi nw tol elim alim)
  38.         (declare
  39.          (ignore var-0 var-1 var-2 var-3 var-4 var-5 var-6 var-8 var-9 var-10))
  40.         (setf nw var-7))
  41.       (go label40)
  42.      label20
  43.       (if (< az rl) (go label30))
  44.       (multiple-value-bind
  45.           (var-0 var-1 var-2 var-3 var-4 var-5 var-6 var-7 var-8 var-9 var-10
  46.            var-11)
  47.           (zasyi znr zni fnu kode nn yr yi nw rl tol elim alim)
  48.         (declare
  49.          (ignore var-0 var-1 var-2 var-3 var-4 var-5 var-6 var-8 var-9 var-10
  50.           var-11))
  51.         (setf nw var-7))
  52.       (if (< nw 0) (go label80))
  53.       (go label40)
  54.      label30
  55.       (multiple-value-bind
  56.           (var-0 var-1 var-2 var-3 var-4 var-5 var-6 var-7 var-8)
  57.           (zmlri znr zni fnu kode nn yr yi nw tol)
  58.         (declare (ignore var-0 var-1 var-2 var-3 var-4 var-5 var-6 var-8))
  59.         (setf nw var-7))
  60.       (if (< nw 0) (go label80))
  61.      label40
  62.       (multiple-value-bind
  63.           (var-0 var-1 var-2 var-3 var-4 var-5 var-6 var-7 var-8 var-9 var-10)
  64.           (zbknu znr zni fnu kode 1 cyr cyi nw tol elim alim)
  65.         (declare
  66.          (ignore var-0 var-1 var-2 var-3 var-4 var-5 var-6 var-8 var-9 var-10))
  67.         (setf nw var-7))
  68.       (if (/= nw 0) (go label80))
  69.       (setf fmr (coerce (the f2cl-lib:integer4 mr) 'double-float))
  70.       (setf sgn (coerce (- (f2cl-lib:dsign pi_ fmr)) 'double-float))
  71.       (setf csgnr 0.0)
  72.       (setf csgni sgn)
  73.       (if (= kode 1) (go label50))
  74.       (setf yy (- zni))
  75.       (setf csgnr (* (- csgni) (sin yy)))
  76.       (setf csgni (* csgni (cos yy)))
  77.      label50
  78.       (setf inu (f2cl-lib:int fnu))
  79.       (setf arg (* (- fnu inu) sgn))
  80.       (setf cspnr (cos arg))
  81.       (setf cspni (sin arg))
  82.       (if (= (mod inu 2) 0) (go label60))
  83.       (setf cspnr (- cspnr))
  84.       (setf cspni (- cspni))
  85.      label60
  86.       (setf c1r (f2cl-lib:fref cyr (1) ((1 2))))
  87.       (setf c1i (f2cl-lib:fref cyi (1) ((1 2))))
  88.       (setf c2r (f2cl-lib:fref yr (1) ((1 n))))
  89.       (setf c2i (f2cl-lib:fref yi (1) ((1 n))))
  90.       (if (= kode 1) (go label70))
  91.       (setf iuf 0)
  92.       (setf ascle (/ (* 1000.0 (f2cl-lib:d1mach 1)) tol))
  93.       (multiple-value-bind
  94.           (var-0 var-1 var-2 var-3 var-4 var-5 var-6 var-7 var-8 var-9)
  95.           (zs1s2 znr zni c1r c1i c2r c2i nw ascle alim iuf)
  96.         (declare (ignore var-0 var-1 var-7 var-8))
  97.         (setf c1r var-2)
  98.         (setf c1i var-3)
  99.         (setf c2r var-4)
  100.         (setf c2i var-5)
  101.         (setf nw var-6)
  102.         (setf iuf var-9))
  103.       (setf nz (f2cl-lib:int-add nz nw))
  104.      label70
  105.       (f2cl-lib:fset (f2cl-lib:fref yr (1) ((1 n)))
  106.                      (- (+ (- (* cspnr c1r) (* cspni c1i)) (* csgnr c2r))
  107.                         (* csgni c2i)))
  108.       (f2cl-lib:fset (f2cl-lib:fref yi (1) ((1 n)))
  109.                      (+ (* cspnr c1i)
  110.                         (* cspni c1r)
  111.                         (* csgnr c2i)
  112.                         (* csgni c2r)))
  113.       (go end_label)
  114.      label80
  115.       (setf nz -1)
  116.       (if (= nw -2) (setf nz -2))
  117.       (go end_label)
  118.      end_label
  119.       (return (values nil nil nil nil nil nil nil nil nz nil nil nil nil)))))
  120.  
  121.